home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Src / modops.c < prev    next >
C/C++ Source or Header  |  1993-07-07  |  10KB  |  417 lines
  1. /* ******************************************************************** */
  2. /* modops.c          Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* Dynamic module manipulation                                          */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * Change Log:
  9.  *   Version 1, June 1990 
  10.  */
  11.  
  12. #include "funcalls.h"
  13. #include "defs.h"
  14. #include "structs.h"
  15. #include "error.h"
  16. #include "global.h"
  17.  
  18. #include "symboot.h"
  19. #include "allocate.h"
  20. #include "modules.h"
  21. #include "specials.h"
  22. #include "modboot.h"
  23. #include "root.h"
  24. #include "table.h"
  25. #include "modops.h"
  26.  
  27. /* Dynamic module loading... */
  28.  
  29. EUFUN_1( Fn_dynamic_load_module, name)
  30. {
  31.   extern LispObject load_module(LispObject*);
  32.  
  33.   if (!is_symbol(name))
  34.     CallError(stacktop,
  35.           "dynamic-load-module: not a symbolic name",name,NONCONTINUABLE);
  36.  
  37.   EUCALL_1(load_module,name);
  38.  
  39.   return(get_module(stacktop,ARG_0(stackbase)));
  40. }
  41. EUFUN_CLOSE
  42.  
  43. extern LispObject Fn_module_value(LispObject*);
  44.  
  45. EUFUN_2( Fn_dynamic_accessiblep, mod, sym)
  46. {
  47.   if (!is_symbol(sym))
  48.     CallError(stacktop,"dynamic-accessiblep: non-symbol",sym,NONCONTINUABLE);
  49.  
  50.   if (!is_i_module(mod) && !is_c_module(mod))
  51.     CallError(stacktop,"dynamic-accessiblep: non-module",mod,NONCONTINUABLE);
  52.  
  53.   return((module_binding_exists_p(stacktop,mod,sym) ? lisptrue : nil));
  54. }
  55. EUFUN_CLOSE
  56.  
  57. EUFUN_2( Fn_dynamic_access, mod, sym)
  58. {
  59.   if (!is_symbol(sym))
  60.     CallError(stacktop,"dynamic-access: non-symbol",sym,NONCONTINUABLE);
  61.  
  62.   if (!is_i_module(mod) && !is_c_module(mod))
  63.     CallError(stacktop,"dynamic-accessible: non-module",mod,NONCONTINUABLE);
  64.  
  65.   return(EUCALL_2(Fn_module_value,mod,sym));
  66. }
  67. EUFUN_CLOSE
  68.  
  69. EUFUN_1( Fn_get_module, sym)
  70. {
  71.   LispObject val;
  72.  
  73.   if (!is_symbol(sym))
  74.     CallError(stacktop,"get-module: non-symbol",sym,NONCONTINUABLE);
  75.  
  76.   val = get_module(stacktop,sym);
  77.  
  78.   return(val);
  79. }
  80. EUFUN_CLOSE
  81.  
  82. EUFUN_1( Fn_module_name, mod)
  83. {
  84.   if (!is_i_module(mod) && !is_c_module(mod))
  85.     CallError(stacktop,"module-name: not a module",mod,NONCONTINUABLE);
  86.  
  87.   return(mod->I_MODULE.name);
  88. }
  89. EUFUN_CLOSE
  90.  
  91. EUFUN_1( Fn_module_exports, mod)
  92. {
  93.   if (!is_i_module(mod) && !is_c_module(mod))
  94.     CallError(stacktop,"module-exports: not a module",mod,NONCONTINUABLE);
  95.  
  96.   return(mod->I_MODULE.exported_names); /* Should copy... */
  97. }
  98. EUFUN_CLOSE
  99.  
  100. EUFUN_2(Fn_add_module_export, mod, name)
  101. {    
  102.   LispObject xx;
  103.  
  104.   xx=EUCALL_2(Fn_cons,name, mod->I_MODULE.exported_names);
  105.   mod->I_MODULE.exported_names=xx;
  106.   return nil;
  107. }
  108. EUFUN_CLOSE
  109.  
  110. /* Module junk for bytecode interpreter */
  111.  
  112. EUFUN_2(Fn_make_module, name, nbinds )
  113. {
  114.   char *myspace;
  115.   LispObject newmod,tab;
  116.   LispObject binds;
  117.   int i;
  118.  
  119. #ifdef DGC 
  120.   myspace=(char *)allocate_nbytes(stacktop,sizeof(MODULE),TYPE_C_MODULE);
  121. #else
  122.   myspace=allocate_space(stacktop,sizeof(MODULE));
  123. #endif
  124.  
  125.   tab=EUCALL_1(make_table,NULL);
  126.   
  127.   newmod=(LispObject) myspace;
  128.   binds=allocate_static_vector(stacktop,intval(nbinds));
  129.  
  130.   for (i=0; i<intval(nbinds); i++)
  131.     {
  132.       vref(binds,i)=nil; /* NULL maybe */
  133.     }
  134.  
  135.   lval_classof(newmod)=Object;
  136.   lval_typeof(newmod)=TYPE_C_MODULE;
  137.   /* hack */
  138. #ifndef DGC
  139.   gcof(newmod)=gcof(nil);
  140.   ageof(newmod)=0;
  141. #endif
  142.   newmod->MODULE.name=name;
  143.   newmod->MODULE.imported_modules=nil;
  144.   newmod->MODULE.bindings=tab;
  145.   newmod->MODULE.exported_names=nil;
  146.   newmod->C_MODULE.values=binds;
  147.   newmod->C_MODULE.entry_count=nbinds;
  148.   newmod->C_MODULE.home=nil;
  149.   put_module(stacktop,newmod->MODULE.name,newmod);
  150.  
  151.   return newmod;
  152. }
  153. EUFUN_CLOSE
  154.  
  155. static EUFUN_2(Fn_binding_location,mod,name)
  156. {
  157.   LispObject bind;
  158.  
  159.   bind=GET_BINDING(mod,name);
  160.  
  161.   return (BINDING_VALUE(bind));
  162. }
  163. EUFUN_CLOSE
  164.  
  165. static EUFUN_2(Fn_binding_home,mod,name)
  166. {
  167.   LispObject bind;
  168.  
  169.   bind=GET_BINDING(mod,name);
  170.  
  171.   return (BINDING_HOME(bind));
  172. }
  173. EUFUN_CLOSE
  174.  
  175. static EUFUN_4(Fn_add_import,mod,name,inmod,inname)
  176. {
  177.   LispObject bind;
  178.  
  179.   bind=GET_BINDING(inmod,inname);
  180.  
  181.   IMPORT_BINDING(ARG_0(stackbase)/*mod*/,ARG_1(stackbase)/*name*/,bind);
  182.   
  183.   return nil;
  184. }
  185. EUFUN_CLOSE
  186.  
  187. EUFUN_3(Fn_add_binding,mod,name,loc)
  188. {
  189.   
  190.   ADD_BINDING(ARG_0(stackbase)/*mod*/,name,loc,nil);
  191.   
  192.   return nil;
  193. }
  194. EUFUN_CLOSE
  195.  
  196. static EUFUN_2(Fn_module_val,mod,n)
  197. {
  198.   return (vref((mod->C_MODULE.values),intval(n)));
  199. }
  200. EUFUN_CLOSE
  201.  
  202. static EUFUN_3(Fn_module_val_setter,mod,n,val)
  203. {
  204.   vref((mod->C_MODULE.values),intval(n))=val;
  205.   
  206.   return nil;
  207. }
  208. EUFUN_CLOSE
  209.  
  210. /* DJB Type hacks */
  211. /* would be real nice if this was a function */
  212. EUFUN_3(Sf_reify_env,mod,env,form)
  213. {
  214.   LispObject lst=nil;
  215.   LispObject ptr;
  216.   
  217.   ptr=env;
  218.  
  219.   while (ptr!=NULL)
  220.     {
  221.       LispObject xx;
  222.  
  223.       STACK_TMP(ptr->ENV.next);
  224.       STACK_TMP(lst);
  225.       xx=EUCALL_2(Fn_cons,ptr->ENV.variable,ptr->ENV.value);
  226.       UNSTACK_TMP(lst);
  227.       lst=EUCALL_2(Fn_cons,xx,lst);
  228.       UNSTACK_TMP(ptr);
  229.     }
  230.   lst=EUCALL_2(Fn_cons,ARG_0(stackbase)->MODULE.name,lst);
  231.   return lst;
  232. }
  233. EUFUN_CLOSE
  234.  
  235. EUFUN_2(Fn_make_function, envlst, body)
  236. {    /* CAR(body) should be an arglist */
  237.  
  238.   LispObject env=NULL;
  239.   LispObject mod;
  240.   LispObject ptr=CDR(envlst);
  241.   
  242.   while(ptr!=nil)
  243.     {
  244.       STACK_TMP(CDR(ptr));
  245.       env=allocate_env(stacktop,CAR(CAR(ptr)),CDR(CAR(ptr)), env);
  246.       
  247.       UNSTACK_TMP(ptr);
  248.     }
  249.   
  250.   STACK_TMP(env);
  251.   mod=get_module(stacktop,CAR(ARG_0(stackbase))/*name*/);
  252.   UNSTACK_TMP(env);
  253.  
  254.   return(EUCALL_3(Sf_lambda,mod,env,ARG_1(stackbase)));
  255. }
  256. EUFUN_CLOSE
  257.  
  258. static EUFUN_1(Fn_function_body, fn)
  259. {
  260.   if (!is_i_function(fn))
  261.     CallError(stacktop,"Fn_body: not an i-function",fn,NONCONTINUABLE);
  262.   
  263.   /*Should add the lambda-list! */
  264.   return fn->I_FUNCTION.body;
  265. }
  266. EUFUN_CLOSE
  267.  
  268. EUFUN_1(Fn_function_env, fn)
  269. {
  270.   LispObject lst;
  271.   if (!is_i_function(fn))
  272.     CallError(stacktop,"Fn_body: not an i-function",fn,NONCONTINUABLE);
  273.  
  274.   lst=EUCALL_1(Fn_listify_env,fn->I_FUNCTION.env);
  275.   lst=EUCALL_2(Fn_cons,(fn->I_FUNCTION.home)->MODULE.name,lst);
  276.  
  277.   return lst;
  278. }
  279. EUFUN_CLOSE
  280.  
  281. EUFUN_1(Fn_listify_env,e)
  282. {    
  283.   LispObject ptr, lst;
  284.   
  285.   lst=nil;
  286.   ptr=e;
  287.  
  288.   while (ptr!=NULL)
  289.     {
  290.       LispObject xx;
  291.  
  292.       STACK_TMP(ptr->ENV.next);
  293.       STACK_TMP(lst);
  294.       xx=EUCALL_2(Fn_cons,ptr->ENV.variable,ptr->ENV.value);
  295.       UNSTACK_TMP(lst);
  296.       lst=EUCALL_2(Fn_cons,xx,lst);
  297.       UNSTACK_TMP(ptr);
  298.     }
  299.   return lst;
  300.  
  301. }
  302. EUFUN_CLOSE
  303.  
  304. EUFUN_2(Fn_modify_function_env, fn, envlst)
  305. {
  306.   LispObject env=NULL;
  307.   LispObject mod;
  308.   LispObject ptr=CDR(envlst);
  309.   
  310.   if (!is_i_function(fn))
  311.     CallError(stacktop,"Fn_body: not an i-function",fn,NONCONTINUABLE);
  312.  
  313.   while(ptr!=nil)
  314.     {
  315.       STACK_TMP(CDR(ptr));
  316.       env=allocate_env(stacktop,CAR(CAR(ptr)),CDR(CAR(ptr)), env);
  317.       
  318.       UNSTACK_TMP(ptr);
  319.     }
  320.   
  321.   STACK_TMP(env);
  322.   mod=get_module(stacktop,CAR(ARG_1(stackbase))/*name*/);
  323.   UNSTACK_TMP(env);
  324.  
  325.   fn->I_FUNCTION.env = env;
  326.   fn->I_FUNCTION.home = mod;
  327.  
  328.   return fn;
  329. }
  330. EUFUN_CLOSE
  331.  
  332. /* 
  333.  * Gobbing out a description file
  334.  * 
  335.  * Contains location info of all loaded modules
  336.  */
  337.  
  338. void make_description_file(LispObject *stacktop)
  339. {
  340. #ifdef BCI
  341.   extern LispObject Fn_boot_module_list(LispObject *);
  342.  
  343.   FILE *file;
  344.   LispObject mods,cmods;
  345.   int i=1;
  346.   /* XXX This needs changing 'cos of demise of table_keys */
  347.   file=fopen("you.mods","w");
  348.   
  349.   mods=Fn_boot_module_list(stacktop);
  350.   mods=CDR(mods);
  351.   fprintf(file,"(\n");
  352.   while (mods!=nil)
  353.     {
  354.       LispObject vals;
  355.       vals=EUCALL_1(Fn_table_parameters,CAR(mods)->MODULE.bindings);
  356.       fprintf(file,"(%s %d",stringof(CAR(mods)->MODULE.name->SYMBOL.pname),i);
  357.       
  358.       while (vals!=nil)
  359.     {
  360.       fprintf(file," (|%s| . %d)",stringof(CAR(CAR(vals))->SYMBOL.pname), intval(BINDING_VALUE(CDR(CAR(vals)))));
  361.       vals=CDR(vals);
  362.     }
  363.       fprintf(file,")\n");
  364.       
  365.       i++;
  366.       mods=CDR(mods);
  367.     }
  368.   fprintf(file,")\n");
  369.   return;
  370. #else /* no bci */
  371.   return;
  372. #endif
  373. }
  374.  
  375. /*
  376.  * Initialisation...
  377.  */
  378.  
  379. #define MODULE_OPERATORS_ENTRIES 19
  380.  
  381. MODULE Module_module_operators;
  382. LispObject Module_module_operators_values[MODULE_OPERATORS_ENTRIES];
  383.  
  384. void initialise_module_operators(LispObject *stacktop)
  385. {
  386.   open_module(stacktop,
  387.           &Module_module_operators,
  388.           Module_module_operators_values,
  389.           "module-operators",
  390.           MODULE_OPERATORS_ENTRIES);
  391.  
  392.   (void) make_module_function(stacktop,
  393.                   "dynamic-load-module",Fn_dynamic_load_module,1);
  394.   (void) make_module_function(stacktop,"dynamic-access",Fn_dynamic_access,2);
  395.   (void) make_module_function(stacktop,
  396.                   "dynamic-accessible-p",Fn_dynamic_accessiblep,2);
  397.   (void) make_module_function(stacktop,"get-module",Fn_get_module,1);
  398.   (void) make_module_function(stacktop,"module-name",Fn_module_name,1);
  399.   (void) make_module_function(stacktop,"module-exports",Fn_module_exports,1);
  400.  
  401.   (void) make_module_function(stacktop,"add-module-export",Fn_add_module_export,2);
  402.   (void) make_module_function(stacktop,"make-module",Fn_make_module,2);
  403.   (void) make_module_function(stacktop,"module-binding-location",Fn_binding_location,2);
  404.   (void) make_module_function(stacktop,"module-binding-home",Fn_binding_home,2);
  405.   (void) make_module_function(stacktop,"add-module-import",Fn_add_import,4);
  406.   (void) make_module_function(stacktop,"add-module-binding",Fn_add_binding,3);
  407.   (void) make_module_function(stacktop,"module-value",Fn_module_val,2);
  408.   (void) make_module_function(stacktop,"module-value-setter",Fn_module_val_setter,3);
  409.   (void) make_module_special(stacktop,"reify-env",Sf_reify_env);
  410.   (void) make_module_function(stacktop,"make-function",Fn_make_function,2);
  411.   (void) make_module_function(stacktop,"function-body",Fn_function_body,1);
  412.   (void) make_module_function(stacktop,"function-env",Fn_function_env,1);
  413.   (void) make_module_function(stacktop,"modify-function-env",Fn_modify_function_env,2);
  414.   close_module();
  415. }
  416.  
  417.